home *** CD-ROM | disk | FTP | other *** search
/ Tech Arsenal 1 / Tech Arsenal (Arsenal Computer).ISO / tek-06 / mcmenu.zip / MCTREE.PAS < prev    next >
Pascal/Delphi Source File  |  1992-07-01  |  15KB  |  520 lines
  1. PROGRAM MCTree;
  2.  { works with MCmenu 1.010 to generate a tree structure of the
  3.    .mnu file fed to it.
  4.   the tree file is written to same name as MN.tre in current dir
  5.  }
  6.  
  7. { ver 0.000
  8.           ^ bug fix
  9.         ^^  minor rev
  10.       ^     major rev
  11. { Turbo Pascal 5.5 }
  12.  
  13.  
  14. { Public Domain, Absolutly NO liability accepted!                 }
  15. { Processes Novell type menu  using 0k with Hard drive menu ability}
  16. { and hooks to Remote Procedure Calls }
  17. { Uses Novell menu script but ignores colours, menu locators }
  18. { need more features, you have the source.    }
  19. { NOTE uses Env Var MN to name menu to use or Command Line overide }
  20.  
  21. USES Crt,Dos,Win,SysSup,TextMenu;
  22.  
  23. {L Win }
  24. {L SysSup}
  25. {L TextMenu }
  26. { 0.800 }
  27. {$M 32768,100000,100000}
  28.  
  29. CONST
  30.   verstr  = '0.000';
  31.   blanks  = '                                                                     ';
  32.   { 0.900 }
  33.   maxdata= 4000;
  34.   maxmenu=200;
  35.   { 0.726 }
  36.   fnamechar='X';
  37.  
  38. TYPE
  39.   menunumtype= 0..maxmenu;
  40.   mcmenutype= RECORD
  41.                 num: 1..mxonmenu;
  42.                 strs: ARRAY[0..mxonmenu+1] OF 1..maxdata; { +1 to find end of item }
  43.                 issub: ARRAY[1..mxonmenu] OF BOOLEAN;
  44.                 menuidx: ARRAY[1..mxonmenu] OF menunumtype;
  45.               END;
  46.  
  47. VAR
  48.   escapeok,escaped: BOOLEAN;
  49.   ch: CHAR;
  50.   ttlscr: winrecptr;
  51.   curhelp: STRING;
  52.   reg: REGISTERS;
  53.   oldhelpvec,oldhk2vec: POINTER;
  54.   cnt,maxcnt: INTEGER;
  55.   filestr: STRING;
  56.   mdatastr: ARRAY[1..maxdata] OF ^STRING;
  57.   numdata: 1..maxdata;
  58.   menus: ARRAY[0..maxmenu] OF mcmenutype;
  59.   cl: BOOLEAN;
  60.   dosverstr: STRING[10];
  61.   { 0.800 }
  62.   rpcok: BOOLEAN;
  63.  
  64.   totmenu: menunumtype;
  65.  
  66.   f: TEXT;
  67.  
  68.  
  69.   PROCEDURE stufkeyp(codekey: INTEGER); EXTERNAL;
  70.  {$L STUFKEYP.OBJ}
  71.  
  72.   PROCEDURE titlemsg(title: STRING;VAR  wn: winrecptr);
  73.   VAR
  74.     attr: INTEGER;
  75.   BEGIN  {titlemsg}
  76.     openwindow(2,2,79,2,wn);
  77.     IF lastmode=mono THEN
  78.       attr:=darkgray+lightgray*16
  79.     ELSE
  80.       attr:= blue+cyan*16;
  81.  
  82.     fillwin(#32,attr);
  83.     writestr(1,1,title,attr);
  84.   END; { titlemsg }
  85.  
  86.  
  87.   PROCEDURE error(str: STRING);
  88.   VAR
  89.     i: INTEGER;
  90.   BEGIN  { error }
  91.     window(1,1,80,25);
  92.     textbackground(black);
  93.     textcolor(lightgray);
  94.     clrscr;
  95.     SETINTVEC(250,oldhelpvec);
  96.     SETINTVEC(251,oldhk2vec);
  97.     textmode(lastmode);
  98.     { 0.910 }
  99.     WRITELN;
  100.     WRITELN(CONCAT('MC Menu Ver ',verstr,'  E R R O R.'));
  101.     WRITELN;
  102.     WRITE('       ');
  103.     WRITELN(str);
  104.     WRITELN;
  105.     WRITELN;
  106.  
  107.     { 0.910 }
  108.     FOR i:= 1 TO 8 DO
  109.     BEGIN
  110.       sound(100);
  111.       delay(200);
  112.       sound(500);
  113.       delay(200);
  114.     END;
  115.     nosound;
  116.     HALT(1);
  117.   END; { error }
  118.  
  119.   PROCEDURE help;  INTERRUPT; { vector 250 }
  120.   CONST
  121.     helpattr= black+lightgray*16;
  122.  
  123.   VAR
  124.     helpwin: winrecptr;
  125.     oldwin: winstate;
  126.     i: INTEGER;
  127.     key: CHAR;
  128.     helphack: INTEGER;
  129.   BEGIN { help }
  130.     inhelp:= TRUE;
  131.     savewin(oldwin);
  132.     openwindow(1,4,80,25,helpwin);
  133.     tframewin('MC Menu Help',singleframe,helpattr,helpattr);
  134.     fillwin(#32, helpattr);
  135.     textattr:=helpattr;
  136.     gotoxy(1,1);
  137.     savewin(helpwin^.state);
  138.     GOTOXY(1,2);
  139.  
  140.     IF (curhelp='General') THEN helphack:=1;
  141.  
  142.     CASE helphack OF
  143.  
  144.       1: BEGIN
  145.         WRITELN;
  146.         WRITELN('           Items with a  »  have a sub menu.');
  147.         WRITELN;
  148.         WRITELN('           Select an item or a submenu by pressing the ENTER key.');
  149.         WRITELN;
  150.         WRITELN('           Choose different items using arrow or alpha keys. ');
  151.         WRITELN;
  152.         IF hasmouse THEN
  153.         BEGIN
  154.           WRITELN('           Mouse Active... left button = RETURN, right = ESC.');
  155.           WRITELN;
  156.         END; { hasmouse }
  157.         WRITELN('           Exit a submenu with the ESC key.');
  158.         WRITELN;
  159.         { 0.716 }
  160.         IF escapeok THEN
  161.           WRITELN('           Exit the Main Menu with the ESC key.');
  162.         WriteStr(16,17,
  163.           'Public Domain by Tony Bigras February 29 1992',
  164.           helpattr);
  165.       END { 1 };
  166.  
  167.     END; { CASE }
  168.     WriteSTr(26,19,'Press <ESC> to leave Help.',helpattr);
  169.     key:= allowkey([CHAR(esc)],-1);
  170.     restorewin(helpwin^.state);
  171.     unframewin;
  172.     closewindow(helpwin);
  173.     restorewin(oldwin);
  174.     inhelp:= FALSE;
  175.   END; { help }
  176.  
  177.   PROCEDURE titlescreen;
  178.   VAR
  179.     attr: INTEGER;
  180.     attrf1: INTEGER;
  181.   BEGIN { titlescreen }
  182.     openwindow(1,1,80,3,ttlscr);
  183.     IF lastmode=mono THEN
  184.     BEGIN
  185.       attr:= black+lightgray*16;
  186.       attrf1:=darkgray+black*16;
  187.     END
  188.     ELSE
  189.     BEGIN
  190.       attr:= blue+cyan*16;
  191.       attrf1:=white+blue*16;
  192.     END;
  193.     framewin(singleframe,attr);
  194.     WriteStr(1,1,'M C Menu                                                             Ver '+verstr+'  '
  195.      ,attr);
  196.     window(1,4,80,25);
  197.     fillwin(#177,attr);
  198.     WriteStr(1,22,
  199.      '<F1>-Help                                                                         '
  200.      ,attrf1);
  201.   END; { titlescreen }
  202.  
  203.  
  204.   PROCEDURE domainmenu;
  205.  
  206.   CONST
  207.     blankstr= '                                                         ';
  208.     underlinestr=   '_________________________________________________________';
  209.  
  210.   VAR
  211.     i,choice: INTEGER;
  212.     menu: menutype;
  213.     selected: BOOLEAN;
  214.     fname : STRING;
  215.     intab: INTEGER;
  216.  
  217.     PROCEDURE dosubmenu(smen: integer);
  218.     VAR
  219.      i: INTEGER;
  220.      menu: menutype;
  221.     BEGIN { dosubmenu }
  222.       intab:= intab+2;
  223.       IF smen=0 THEN
  224.       BEGIN
  225.         WRITELN(F,COPY(blankstr,1,intab),
  226.                     {menu.title} mdatastr[menus[smen].strs[0]]^);
  227.         WRITELN(F,COPY(blankstr,1,intab),
  228.                  COPY(underlinestr,1,LENGTH(mdatastr[menus[smen].strs[0]]^)));
  229.       END; { first level menu }
  230.       FOR i:= 1 TO menus[smen].num DO
  231.       BEGIN
  232.         WRITELN(F,COPY(blankstr,1,intab),
  233.                  {menu.item[i]} mdatastr[menus[smen].strs[i]]^);
  234.         IF menus[smen].issub[i] THEN
  235.           dosubmenu(menus[smen].menuidx[i]);
  236.       END;
  237.       intab:= intab-2;
  238.     END; { dosubmenu }
  239.  
  240.  
  241.   BEGIN { domainmenu }
  242.     intab:= 0;
  243.     fname:= CONCAT(COPY(filestr,1,LENGTH(filestr)-3),'TRE');
  244.     {$I-}
  245.       ASSIGN(f,fname);
  246.       IF ioresult<>0 THEN
  247.          error(CONCAT('Unable to Write to:  > ',fname));
  248.       REWRITE(f);
  249.         IF ioresult<>0 THEN
  250.           error(CONCAT('Unable to Write to:  > ',fname));
  251.  
  252.       dosubmenu(0);
  253.  
  254.       CLOSE(f);
  255.       IF ioresult<>0 THEN
  256.          error(CONCAT('Unable to Write to  > ',fname));
  257.     {$I+}
  258.  
  259.   END; { domainmenu }
  260.  
  261.   {$I- }
  262.   PROCEDURE getinfo;
  263.   VAR
  264.     f: TEXT;
  265.     i,cnt,j,k: INTEGER;
  266.     w: INTEGER;
  267.     tstr,tstr2:STRING;
  268.     ctrlline: BOOLEAN;
  269.  
  270.     PROCEDURE getsubs(menunum: menunumtype);
  271.     VAR
  272.       i,j,k,cnt,tcnt: INTEGER;
  273.       tstr,tstr2,tstr3: STRING;
  274.       notfound: BOOLEAN;
  275.     BEGIN  { getsubs }
  276.       cnt:= menus[menunum].strs[0]+1;
  277.       WHILE (cnt<=numdata) AND (mdatastr[cnt]^[1]<>'%') DO
  278.       BEGIN  { find all menu items }
  279.         IF (mdatastr[cnt]^[1]<>' ') THEN  { must be a menu item }
  280.         BEGIN
  281.           menus[menunum].strs[menus[menunum].num]:=cnt;
  282.           WHILE (mdatastr[cnt+1]^[1]=' ') DO
  283.             mdatastr[cnt+1]^:= COPY(mdatastr[cnt+1]^,2,LENGTH(mdatastr[cnt+1]^)-1);
  284.           menus[menunum].issub[menus[menunum].num]:=(mdatastr[cnt+1]^[1]='%');
  285.           IF menus[menunum].issub[menus[menunum].num] THEN
  286.           BEGIN
  287.             menus[menunum].menuidx[menus[menunum].num]:= totmenu+1;
  288.             { find start of this submenu items menu }
  289.             tcnt:=cnt+2;
  290.             tstr:=mdatastr[menus[menunum].strs[menus[menunum].num]+1]^;
  291.             FOR k:= 1 TO LENGTH(tstr) DO
  292.               tstr[k]:=upcase(tstr[k]);      { convert to all upper case }
  293.             notfound:=TRUE;
  294.             WHILE ((tcnt<=numdata) AND notfound) DO
  295.               IF mdatastr[tcnt]^[1]<>'%' THEN
  296.                 tcnt:=tcnt+1
  297.               ELSE
  298.               BEGIN
  299.                 tstr3:=mdatastr[tcnt]^;
  300.                 FOR k:= 1 TO LENGTH(tstr3) DO
  301.                   tstr3[k]:=upcase(tstr3[k]);  { convert to all upper case }
  302.               notfound:=(POS(tstr,tstr3)=0);
  303.               IF notfound THEN
  304.                tcnt:=tcnt+1;
  305.             END; { WHILE }
  306.             IF tcnt>numdata THEN error(CONCAT('Invalid menu structure:  > ',
  307.               mdatastr[menus[menunum].strs[menus[menunum].num]+1]^));
  308.             totmenu:=totmenu+1;
  309.             menus[totmenu].strs[0]:=tcnt;
  310.             menus[totmenu].num:=1;
  311.  
  312.             { strip location info from menu title}
  313.             IF POS(',',mdatastr[menus[totmenu].strs[0]]^)<>0 THEN
  314.             mdatastr[menus[totmenu].strs[0]]^:=
  315.               COPY(mdatastr[menus[totmenu].strs[0]]^,
  316.               1,POS(',',mdatastr[menus[totmenu].strs[0]]^)-1);
  317.             getsubs(totmenu);
  318.           END; { is sub menu }
  319.           menus[menunum].num:=menus[menunum].num+1;
  320.           menus[menunum].strs[menus[menunum].num]:=cnt;
  321.  
  322.           cnt:=cnt+1; { was menu item and next item was de spaced }
  323.         END; { IF valid item for menu }
  324.         cnt:=cnt+1;
  325.       END; { While cnt }
  326.       menus[menunum].strs[menus[menunum].num]:=cnt;
  327.       IF cnt=numdata THEN
  328.         inc(menus[menunum].strs[menus[menunum].num]);
  329.       menus[menunum].num:=menus[menunum].num-1;
  330.     END; { getsubs }
  331.  
  332.   BEGIN { getinfo }
  333.     ASSIGN(f,filestr); { let DOS try to find it }
  334.     RESET(f);
  335.     IF (IORESULT<>0) THEN
  336.     BEGIN
  337.       { 1.010  DOS could not find it, now  check program directory }
  338.       tstr:=paramstr(0); { get full path and program name }
  339.       i:= LENGTH(tstr)+1;
  340.       REPEAT
  341.         i:= i-1;
  342.       UNTIL (tstr[i]='\');
  343.       tstr:= COPY(tstr,1,i); { now it is just the full path }
  344.       tstr:= CONCAT(tstr,filestr);
  345.       ASSIGN(f,tstr);
  346.       RESET(f);
  347.       IF (IORESULT<>0) THEN
  348.         error(CONCAT('Unable to open menu file:  > ',filestr));
  349.     END;
  350.     { read em all into mdatastr array }
  351.     numdata:=1;
  352.     REPEAT
  353.       READLN(f,tstr);
  354.       FOR i:= 1 TO LENGTH(tstr) DO
  355.         IF (tstr[i]=CHR(09))OR
  356.            (tstr[i]=CHR(175)) THEN {  strip double arrow chr }
  357.                                    { left over due to old menus }
  358.                                    { that used it to indicate subs }
  359.            tstr[i]:= CHR(32);  { convert tab to 1 space }
  360.       numdata:=numdata+1;
  361.       { .711 did not handle lines of blanks correctly }
  362.       IF POS(tstr,blanks)<>0 THEN { it is just blanks }
  363.         numdata:= numdata-1
  364.       ELSE
  365.       BEGIN
  366.         { ptrupdate
  367.           get some space  size of string  }
  368.  
  369.         GETMEM(mdatastr[numdata-1],LENGTH(tstr)+2);
  370.         mdatastr[numdata-1]^:=tstr;
  371.  
  372.       END; { add item }
  373.  
  374.     UNTIL EOF(f);
  375.     numdata:=numdata-1;
  376.     CLOSE(F);
  377.     { 0.716 }
  378.     { 0.800 }
  379.      ctrlline:=  (mdatastr[numdata]^[1]='!');
  380.      escapeok:= TRUE;
  381.      rpcok:= FALSE;
  382.      IF ctrlline THEN
  383.      BEGIN
  384.        IF mdatastr[numdata]^='!' THEN
  385.          escapeok:= FALSE
  386.          { retain for old escape method '!' is no escape }
  387.        ELSE
  388.          escapeok:= (0=POS('!',mdatastr[numdata]^[2])); { !! is escape }
  389.        rpcok:= (0<>POS('R',mdatastr[numdata]^));       { !R is do rpc }
  390.        numdata:=numdata-1;
  391.      END;
  392.     menus[0].num:=1;
  393.     menus[0].strs[0]:=1;
  394.     IF (mdatastr[menus[0].strs[0]]^[1]<>'%') THEN
  395.       error(CONCAT('First line must be menu:  > ',mdatastr[menus[0].strs[0]]^));
  396.  
  397.         { strip % and location info from menu title}
  398.     mdatastr[menus[0].strs[0]]^:= COPY(mdatastr[menus[0].strs[0]]^,2,
  399.       LENGTH(mdatastr[menus[0].strs[0]]^));
  400.         IF POS(',',mdatastr[menus[0].strs[0]]^)<>0 THEN
  401.           mdatastr[menus[0].strs[0]]^:=COPY(mdatastr[menus[0].strs[0]]^,
  402.           1,POS(',',mdatastr[menus[0].strs[0]]^)-1);
  403.     menus[0].strs[0]:=1;
  404.     getsubs(0);
  405.  
  406.     FOR i:= 1 to numdata DO  { strip leading % from all strings }
  407.       IF   mdatastr[i]^[1]='%' THEN
  408.         mdatastr[i]^:= COPY(mdatastr[i]^,2,LENGTH(mdatastr[i]^)-1);
  409.     FOR i:= 0 to totmenu DO
  410.     BEGIN
  411.       w:=1;
  412.       { now put markers on end of items with submenus. }
  413.       FOR k:= 0 TO menus[i].num DO
  414.         w:=max(w,LENGTH(mdatastr[menus[i].strs[k]]^));
  415.       FOR k:= 1 TO menus[i].num DO
  416.       BEGIN
  417.         IF menus[i].issub[k] THEN
  418.         BEGIN
  419.           tstr2:=mdatastr[menus[i].strs[k]]^;
  420.           FREEMEM(mdatastr[menus[i].strs[k]],
  421.              LENGTH(mdatastr[menus[i].strs[k]]^)+2);
  422.           tstr2:=CONCAT(tstr2,COPY(blanks,1,w-LENGTH(tstr2)),' »');
  423.           GETMEM(mdatastr[menus[i].strs[k]],LENGTH(tstr2)+2);
  424.           mdatastr[menus[i].strs[k]]^:=tstr2;
  425.         END;  { is sub }
  426.       END; { K }
  427.     END; { I }
  428.   END; { getinfo }
  429.   {$I+ }
  430.  
  431.   PROCEDURE initalize;
  432.   VAR
  433.     i: INTEGER;
  434.     s1: STRING;
  435.  
  436.   BEGIN  { initalize }
  437.     GETINTVEC(250,oldhelpvec);
  438.     SETINTVEC(250,@help);
  439.     helpon:= TRUE;
  440.     delay(10);
  441.  
  442.     { .712 }
  443.     reg.AH:= 01;
  444.     reg.CH:= $20;
  445.     reg.CL:= 08;
  446.     INTR($10,reg);   { Turn cursor off }
  447.  
  448.     { 0.713 }
  449.     reg.AX:= 00;
  450.     INTR($33,reg);   { check for mouse and reset }
  451.     hasmouse:= (reg.ax=$FFFF);
  452.  
  453.     { 0.714 }
  454.     reg.AX:=$3000;
  455.     INTR($21,reg); { get dos version }
  456.     IF reg.AL<03 THEN
  457.       error('Requires DOS version 3.00 or greater.');
  458.  
  459.     STR(reg.AL:1,dosverstr);
  460.     STR(reg.AH:2,s1);
  461.     FOR i:= 1 TO LENGTH(s1) DO
  462.       IF s1[i]=' ' THEN
  463.         s1[i]:='0';
  464.     dosverstr:=CONCAT(dosverstr,'.',s1);
  465.     { 0.715 } { find PSP and figure out this programs name. }
  466.     reg.AH:=$62;
  467.     INTR($21,reg);
  468.     { reg.BX = segment of psp which is at offset 0 }
  469.     { more needed to figure out the program name    }
  470.  
  471.     clrscr;
  472.     checkbreak := FALSE;
  473.     IF lastmode=mono THEN
  474.       textattr:=lightgray+black*16
  475.     ELSE
  476.       textattr := lightgray+blue * 16;
  477.     RANDOMIZE;
  478.     { get filename from command line or if none on cl then from env var MN }
  479.     cl:= FALSE;
  480.     IF paramcount<1 THEN
  481.       filestr:=getenv('MN')
  482.     ELSE
  483.     BEGIN
  484.       cl:= TRUE;
  485.       filestr:= paramstr(1);
  486.     END;
  487.     { now extend file if it dosent have an extension , use .MNU }
  488.     IF (POS('.',filestr)=0)AND (filestr<>'') THEN
  489.       filestr:=CONCAT(filestr,'.MNU');
  490.     IF (filestr='') THEN
  491.       filestr:= 'No MN environment';
  492.  
  493.     totmenu:=0;
  494.     getinfo;
  495.  
  496.      { 0.729 }
  497.      blankerstr:=CONCAT(' M C Menu  Ver ',verstr,' ');
  498.  
  499.   END; { initalize }
  500.  
  501.  
  502. BEGIN { MCTree }
  503.  
  504.   initalize;
  505.   titlescreen;
  506.   window(1,1,80,25);
  507.   curhelp:='General';
  508.   escaped:= FALSE;
  509.  
  510.   domainmenu;
  511.  
  512.   window(1,1,80,25);
  513.   textbackground(black);
  514.   textcolor(lightgray);
  515.   clrscr;
  516.   SETINTVEC(250,oldhelpvec);
  517.  
  518.   textmode(lastmode); { turn cursor on  }
  519. END . { MCTree }
  520.